perm filename NEW.FAI[XX,LCS]4 blob
sn#229090 filedate 1976-08-02 generic text, type T, neo UTF8
00100 TITLE BMSTF ;0300 SUBROUTINE BMSTF
00200 ENTRY BMSTF
00300 EXTERNAL STAFF,RHORZ,AMOD,NOZERO,LINES,BMS,MAKNUM
00400 EXTERNAL .COMM.,ALF,POSI,STF,MIN,BM,PLTR
00500 BMSTF: 0 ;00400 IMPLICIT INTEGER(A-Q,S-Z)
00600 ;00500 REAL DIS,DISX,HGT,POS,CENTR,STFF,HGT1
00700 ;00600 COMMON/STF/RSTFAC(-3/4),RSTJ2/MIN/MINI,RMINI
00800 ;00700 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/BM/RA,RC,RJY
00900 ;00800 COMMON/POSI/STFF(-3/4),JJ2,POS/PLTR/PLT,RHT,DIS
01000 ;00900 COMMON/ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
01100 ;01000 1 RJA,YY,DISX,HGT,RZ,INP(53)
01200 ;01100 EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3))
01300 ;01200 1,(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
01400 ;01300 1,(J11,JQ(9)),(J6,JQ(4)),(R9,RJQ(7)),(R8,RJQ(6)),(R3,RJQ(1
01500 ;01400 1 ,(R7,RJQ(5)),(R4,RJQ(2)),(R9,RJQ(7)),(R10,RJQ(8)),(RX3,R
01600 ;01500 DATA R14/14.54/,RTF/3.0/,RHGT/48.0/,R2HGT/96.0/,RBM/.83/
01700 ;01600 C RDBR IS SPACER FOR DBL BAR.
01800 ; 01710 IF(JA.NE.8)GO TO 100
01900 MOVEI 02,10
02000 CAME 02,.COMM.+1
02100 JRST BS100
02200 ; 01720 CALL STAFF
02300 JSA 16,STAFF
02400 JRA 16,(16) ;1730 RETURN
02500 ; 02000 C TO COMPENSATE FOR NOTE #3 COMING AT POS=0
02600 ; 02200 R3Q=R3
02700 BS100: MOVE 13,.COMM.+4
02800 MOVE 10,.COMM.+=31 ; 10 IS J10, 13 IS R3Q
02900 ; 02400 C NEXT IS FOR BEAMS
03000 ; 02500 RMINI=RSTJ2
03100 MOVE 12,STF+=8
03200 MOVEM 12,MIN+1
03300 ; 02600 RX=2.7*RSTJ2*5.96
03400 FMPR 12,[16.092] ; 12 IS RX
03500 MOVE 5,.COMM.+=10 ; SAVE R9 IN 5
03600 MOVE 6,.COMM.+=28 ; 6 IS J7
03700 MOVE 14,.COMM.+=29 ; J8
03800 ;; MOVE .COMM.+5 ;IF(R4.GE.80)R4=R4-100
03900 ;; CAMGE [-20.0] ;CHECK FOR -95, ETC.
04000 ;; FADR [100.0]
04100 ;; CAMGE [80.0] ;CATCHES SOME NEG. MINIS (I.E.<-100)
04200 ;; JRST .+3
04300 ;; FSBR [100.0]
04400 ;; MOVEM .COMM.+5 ;**** ALL DONE IN CENTX NOW (LOOP.FAI)****
04500 JSA 16,RHORZ ; 02800 R6=RHORZ(R6)
04600 JUMP .COMM.+7
04700 MOVEM 00,.COMM.+7
04800 ;*** MOVSI 2,204500 ; (10.0) IF(R8.NE.0)GO TO 204
04900 ;*** SKIPN .COMM.+=9
05000 ;*** CAMG 2,.COMM.+=11
05100 ;*** JRST BS204 ; IF(R10.GE.10)GO TO 204
05200 ;; JUMPE 5,BSJ8 ; IF(J9.EQ.0)GO TO BSJ8 *** NEW***
05300 JUMPGE 14,BSJ8 ; IF(J8.GE.0)GO TO BSJ8 ***NEW***
05350 JUMPE 5,BS91+2
05400 MOVN 10,14
05500 ;; SETZM .COMM.+=9 ;R8=0
05600 BSJ8: JUMPL 6,BS204 ; 03100 IF(J7)GO TO 204
05700 SKIPN 10 ;IF(J10.NOW IS NE.0)GO TO 204
05800 JUMPN 5,BS1 ; 03200 IF(R9.NE.0)GO TO 1
05900 ; R8=0 AND R9=NUM -- PUTS NUMBER OUTSIDE BEAM(FOR TRIPLET
06000 BS204: JUMPE 5,BSR9 ;03400 204 IF(R9.NE.0)R9=RHORZ(R9)
06100 ;; JUMPG 5,BSX9
06200 ;; MOVE 5,0 ;IF(R9.LT.0)R9=R6 ***NEW***
06300 ;; JRST BSR9
06400 BSX9: JSA 16,RHORZ
06500 JUMP .COMM.+=10
06600 MOVEM 5 ; 5 IS R9
06700 BSR9: JUMPL 6,BS201 ; IF(J7)GO TO 201
06800 ;***BS200: CAIGE 10,=10 ; 200 IF(J10.LT.10)GO TO 91
06900 ;*** JRST BS91
07000 ;; JUMPE 10,BS91 ;IF(J10.EQ.0)GO TO 91 NEXT FOR INNER, PARTIAL BEAMS
07100 ;; CAME 14,[-1]
07200 ;; JRST BSX8 ;IF(R8.EQ.-1)R8=R3 ***NEW***
07300 ;; MOVEM 13,.COMM.+=9
07400 ;; JRST BSR8
07500 JUMPE 14,BS91 ;IF(J8.EQ.0)GO TO 91
07600 JUMPLE 14,BSR8 ;IF(J8.LE.0)GO TO BSR8
07700 BSX8: JSA 16,RHORZ ; 03800 R8=RHORZ(R8)
07800 JUMP .COMM.+=9
07900 MOVEM 00,.COMM.+=9
08000 ;*** JSA 16,AMOD ; 03900 R10=AMOD(R10,10.)
08100 ;*** JUMP .COMM.+=11
08200 ;*** JUMP [10.0]
08300 ;*** MOVEM 00,.COMM.+=11
08400 BSR8: MOVE 02,10 ;J10/10 =0 OR 1 OR 2
08500 IDIVI 02,12
08600 FLTR 3,3
08700 MOVEM 3,.COMM.+=11 ;R10 NOW = DISPLACEMENT
08800 ;*** CAIN 2,3
08900 ;*** JRST BS4
09000 JUMPN 2,.+3
09100 ADDI 10,12 ;J10=J10+10 CHANGES 1 TO 11, ETC.
09200 JRST BS4
09300 CAIN 2,2
09400 JRST BS3 ;4100 2 RH=R9+RX
09500 BS2: MOVE 02,12
09600 FADR 02,5
09700 MOVEM 02,RH#
09800 ; 04200 GO TO 1
09900 JRST BS1
10000 ; 04300 3 R8=R9-RX
10100 BS3: MOVN 02,12
10200 FADR 02,5
10300 MOVEM 02,.COMM.+=9;10=SHRT PARTIAL LFT↑RT., 20=RT.↑LFT, 30=TO POS IN P8
10400 ; 04500 4 RH=R8
10500 BS4: MOVE 02,.COMM.+=9
10600 MOVEM 02,RH
10700 ; 04600 C LEFT INNER POS.
10800 ; 04700 GO TO 1
10900 JRST BS1
11000 ; 04800 201 J7=-J7
11100 BS201: MOVNS 6
11200 ;4900 C P8=WIDTH OF TREM. P9=0(SANS OTHER BEAMS) OR =POS.3, P10=D
11300 FLTR 0,10 ;5000 CALL NOZERO(R10)
11400 SKIPN
11500 MOVE [1.0] ;ALWAYS AT LEAST 1 IN DISPLACEMENT (AC.0)
11600 ;*** JSA 16,NOZERO
11700 ;*** JUMP .COMM.+=11
11800 MOVEI 10,36 ;05200 J10=30
11900 ; TO ACTIVATE PARTIAL BEAM SECTION
12000 MOVE 02,.COMM.+=30 ;5400 IF(J9.NE.0)GO TO 202
12100 JUMPN 02,BS202
12200 ; 05500 C NEXT FOR TREM. WITHOUT OTHER BEAMS.
12300 MOVSI 02,576400 ;5600 RH=-1
12400 CAIL 6,24 ;5700 IF(J7.GE.20)RH=-RH
12500 MOVNS 2
12600 MOVEM 02,RH
12700 FADR 02,.COMM.+5 ;6000 R5=R4+RH
12800 MOVEM 02,.COMM.+6
12900 ; 06100 R9=R3
13000 MOVE 05,.COMM.+4
13100 ; 06200 R6=R3+22.*RMINI
13200 MOVSI 02,205540
13300 FMPR 02,MIN+1
13400 FADR 02,.COMM.+4
13500 MOVEM 02,.COMM.+7
13600 ; 06300 202 IF(R8.EQ.0)R8=4.
13700 BS202: MOVE 12,.COMM.+=9
13800 JUMPN 12,.+3
13900 MOVSI 12,203400
14000 MOVEM 12,.COMM.+=9
14100 ; 06400 RX=R8*RMINI*2.98
14200 FMPR 12,MIN+1
14300 FMPR 12,[2.98]
14400 ; 06500 RH=R9+RX
14500 MOVE 02,12
14600 FADR 02,5
14700 MOVEM 02,RH
14800 ; 06600 R9=R9-RX
14900 MOVN 02,12
15000 FADRM 02,5
15100 ; 06700 GO TO 1
15200 JRST BS1
15300 BS91: JUMPE 14,BS1 ; 91 IF(J8.EQ.0)GO TO 1
15400 JUMPG 14,BS92 ; IF(J8.GT.0)GO TO 92
15500 ; FOR J8=-(10+DN) OR -(20+DN) R9=R3+RX
15600 MOVE 5,.COMM.+4
15700 FADR 5,12 ; IF(J8.LE.-20)R9=R6-RX
15800 CAMLE 14,[-=20]
15900 JRST .+3
16000 MOVN 5,12
16100 FADR 5,.COMM.+7
16200 ; 07400 192 J8=-J8
16300 BS192: MOVNS 14
16400 BS92: JUMPN 10,.+3 ;92 IF(J10.EQ.0)J10=MOD(J8,10)
16500 MOVE 7,14
16600 IDIVI 7,=10 ; IF(J10.EQ.0)J10=1
16700 SKIPN 10
16800 MOVEI 10,1
16900 FLTR 2,10 ;MOVE 2,10 ; R10=J10
17000 ; TLC 2,232000
17100 ; FADR 2,2
17200 MOVEM 2,.COMM.+=11 ;IF P8 NEG, P9 IS AUTOMATIC, ALSO P10 IF NEEDED.
17300 ; 08000 1 IF(IABS(J4).LT.100)GO TO 97
17400 BS1: MOVM .COMM.+=25
17500 CAIGE 00,=80
17600 JRST BS97
17700 ; 08100 RMINI=.6*RSTJ2
17800 MOVE 02,[0.6]
17900 FMPR 02,STF+=8
18000 MOVEM 02,MIN+1
18100 ;; JSA 16,AMOD ;8200 R5=AMOD(R5,100.0)
18200 ;; JUMP .COMM.+6
18300 ;; JUMP [100.0]
18400 ;; MOVEM 00,.COMM.+6 ; SPACE BETWEEN BEAMS
18500 BS97: MOVSI 2,204540 ;8400 97 RJ=RMINI*11.
18600 FMPR 2,MIN+1
18700 MOVEM 2,ALF+=11
18800 MOVSI 206600 ;MOVE [48.0] ;RW=RMINI*RHGT
18900 FMPR MIN+1
19000 MOVEM ALF+=9 ; DIST. UP OR DOWN FROM NOTE HEAD.
19100 FMPR 2,.COMM.+=11 ;RJA=R10*RJ
19200 MOVEM 2,ALF+=14 ; DISPLACEMENT
19300 MOVEM 5,.COMM.+=10 ; RD=R9
19400 MOVEM 5,ALF+7 ; POSITION 3
19500 FSBR 2,ALF+=9
19600 FADR 02,.COMM.+2 ; RJX=CENTR-RW+RJA
19700 MOVEM 02,ALF+=10 ; FINAL HEIGHT OF LEFT SIDE
19800 ; 09300 C NEG R7=TREMOLO
19900 ; 09400 RX=MOD(J7,10)
20000 MOVE 11,6
20100 IDIVI 11,=10
20200 FLTR 12,12 ;TLC 12,232000
20300 ;FADR 12,12
20400 MOVEI 1,(6) ; PUT J7 IN 1 FOR NOW
20500 SUBI 6,=20 ;9500 JJ2=J7-20
20600 ; 09600 RA=R6
20700 MOVE 02,.COMM.+7
20800 MOVEM 02,BM ; HORIZANTAL DIST.
20900 ; RJY=R5*RST7+POS-RST18-RW+RJA
21000 MOVSI 3,203700 ; 7.0
21100 FMPR 03,.COMM.+6
21200 FSBR 3,[18.0]
21300 FMPR 3,STF+=8
21400 FADR 3,ALF+=14
21500 FADR 3,POSI+=9
21600 FSBR 3,ALF+=9
21700 MOVEM 3,BM+2 ; VERTICAL POS OF RIGHT SIDE.
21800 ; 10000 RW=R14*RMINI
21900 MOVE 4,[14.54]
22000 FMPR 4,MIN+1
22100 MOVEM 4,ALF+=9
22200 ; 10100 RY=1.
22300 MOVSI 02,201400
22400 MOVEM 02,RY#
22500 CAIL 1,24 ;200 IF(J7.GE.20)GO TO 98
22600 JRST BS98 ; JUMP IF STEMS ARE DOWN
22700 ; 10400 RY=-RY
22800 MOVNS 00,RY
22900 ; 10500 C FOR THICKENING INCR.
23000 ADDI 6,=10 ;0600 JJ2=J7-10
23100 ; 10700 RJ=-RJ
23200 MOVNS 00,ALF+=11
23300 ; 10800 RJA=RMINI*R2HGT-2.*RJA
23400 MOVE 02,[96.0]
23500 FMPR 02,MIN+1
23600 MOVE 03,ALF+=14
23700 FSC 03,1
23800 FSBR 02,3
23900 MOVEM 02,ALF+=14
24000 ; 10900 RJX=RJX+RJA
24100 FADRM 02,ALF+=10
24200 ; 11000 RJY=RJY+RJA
24300 FADRM 02,BM+2
24400 ; 11100 R3Q=R3Q+RW
24500 FADRM 4,13 ; POSITION 1
24600 ; 11300 RA=RA+RW
24700 FADRM 4,BM ; POSITION 2
24800 ; 11500 RD=RD+RW
24900 FADRM 4,ALF+7
25000 ; 11700 RH=RH+RW
25100 FADRM 4,RH
25200 ; 11800 98 RSTJ2=RSTJ2*RBM
25300 BS98: MOVE 02,[0.83]
25400 FMPRM 02,STF+=8
25500 ; RBM BRINGS LINES OF BEAMS CLOSER TOGETHER. (=.83)
25600 MOVEM 6,POSI+=8 ; JJ2 12000 93 IF(JJ2.GT.RX)GO TO 94
25700 FLTR 6,6 ;TLC 6,232000
25800 ; FADR 6,6
25900 CAMLE 6,12
26000 JRST BS94
26100 CAIL 10,=10 ;2100 IF(J10.GE.10)GO TO 7
26200 JRST BS7
26300 ;XXX JUMPN 10,BS7 ;IF(J10.NE.0)GO TO 7
26400 ; 12200 C**********************
26500 JUMPE 14,BS94 ; IF(J8.EQ.0)GO TO 94
26600 ; 12400 R3=RW
26700 ; 12500 IF(J9.EQ.0)GO TO 292
26800 MOVE 02,.COMM.+=30
26900 JUMPE 02,BS292
27000 CAIL 14,24 ; IF(J8.GE.20)GO TO 193
27100 JRST BS193
27200 ; 12700 293 RX=R3Q-RD
27300 BS293: MOVE 12,13
27400 FSBR 12,ALF+7
27500 ; 12800 GO TO 194
27600 JRST BS194
27700 ; 12900 7 RHX=RH-R3Q
27800 ; 13000 R3=RD-R3Q
27900 BS7: MOVN 4,13
28000 FADR 4,ALF+7
28100 ; 13100 GO TO 292
28200 JRST BS292
28300 ; 13200 193 RX=RD-RA
28400 BS193: MOVE 12,ALF+7
28500 FSBR 12,BM
28600 ; 13300 194 R3=ABS(RX)
28700 BS194: MOVM 4,12
28800 ; 13400 292 DISX=ABS(R3Q-RA)
28900 BS292: MOVE 02,13
29000 FSBR 02,BM
29100 MOVMM 02,ALF+=16
29200 ; 13500 HGT=RJX-RJY
29300 MOVE 3,ALF+=10
29400 FSBR 3,BM+2
29500 MOVEM 3,HGT#
29600 CAIGE 10,=10 ;3600 IF(J10.GE.10)HGT1=HGT*RHX/DISX
29700 JRST BS10
29800 ;XXX JUMPE 10,BS10 ;IF(J10.EQ.0)GO TO 10
29900 MOVN 1,13
30000 FADR 1,RH
30100 FMPR 1,3
30200 FDVR 1,2 ; 1 HAS -HGT1
30300 ; 13800 R3=R3/DISX
30400 BS10: FDVR 4,ALF+=16
30500 MOVEM 4,.COMM.+4
30600 ; 13900 195 HGT=HGT*R3
30700 FMPRB 4,HGT
30800 ; 14000 196 L=J8/10
30900 ; 14100 J8=0
31000 SETZM .COMM.+=29
31100 CAIL 10,=10 ;14200 IF(J10.GE.10)GO TO 8
31200 JRST BS8
31300 ;XXX JUMPN 10,BS8 ;IF(J10.NE.0)GO TO 8
31400 IDIVI 14,=10 ;( L=J8/10)
31500 CAIN 14,1 ; IF(L.EQ.1)GO TO 95
31600 JRST BS95
31700 ; C BEAM LFT=1, RT=2 (PARAM 8=10 OR 20)
31800 ; 14600 R3Q=RD
31900 MOVE 13,ALF+7
32000 ; 14700 RJX=RJY+HGT
32100 FADR 04,BM+2 ; 4 WAS HGT
32200 MOVEM 04,ALF+=10
32300 ; 14800 GO TO 94
32400 JRST BS94
32500 ; 15000 8 R3Q=RH
32600 BS8: MOVE 13,RH
32700 ; 15200 RJY=RJX-HGT
32800 MOVE 02,ALF+=10
32900 FSBR 02,HGT
33000 MOVEM 02,BM+2
33100 FADRM 1,ALF+=10 ;15300 RJX=RJX-HGT1
33200 ; 15400 GO TO 94
33300 JRST BS94-2
33400 ; 15500 95 RA=RD
33500 ; 15600 RJY=RJX-HGT
33600 BS95: MOVE 02,ALF+=10
33700 FSBR 02,HGT
33800 MOVEM 02,BM+2
33900 MOVE 02,ALF+7
34000 MOVEM 02,BM
34100 BS94: MOVEM 13,ALF+5 ;(R3Q)15700 94 L=7.*RMINI
34200 MOVSI 02,203700
34300 FMPR 02,MIN+1
34400 KIFIX 0,2 ;JSA 16,IFIX
34500 ; JUMP 2
34600 MOVEM 00,ALF+=12
34700 ; 15800 930 RC=0
34800 BS930: SETZM BM+1
34900 ; C MINI LINES HAVE .2 SMALLER BEAMS. MAYBE CHANGE THIS??
35000 ; 16000 CALL LINES(R3Q,RJX,3)
35100 JSA 16,LINES
35200 JUMP ALF+5
35300 JUMP ALF+=10
35400 JUMP [3]
35500 ; 16100 DO 941 K=1,L
35600 MOVEI 15,1
35700 ; 16200 CALL BMS
35800 BS12: JSA 16,BMS
35900 ; 16300 IF(PLT.GE.0)GO TO 940
36000 MOVE 02,PLTR
36100 JUMPGE 02,BS940
36200 ; 16400 RC=RC+RY
36300 MOVE 02,RY
36400 FADRM 02,BM+1 ; FOR THICKENING.
36500 ; 16600 CALL BMS
36600 JSA 16,BMS
36700 MOVE 1,ALF+5 ; CALL EXCH(RA,ALF+5)
36800 EXCH 1,BM
36900 MOVEM 1,ALF+5
37000 MOVE 1,ALF+=10
37100 EXCH 1,BM+2 ; 941 CALL EXCH(RJY,RJX)
37200 MOVEM 1,ALF+=10
37300 CAMGE 15,ALF+=12
37400 AOJA 15,BS12
37500 ; 16900 CALL BMS
37600 JSA 16,BMS ; DRAWS 5 LINES FOR BEAMS.
37700 ; 17100 940 JJ2=JJ2-1
37800 BS940: SOSG POSI+=8
37900 ; 17200 IF(JJ2.LE.0)GO TO 942
38000 JRST BS942 ; IF P7=10 OR 20 ONE BEAM WILL APPEAR.
38100 ; 17400 RJY=RJY+RJ
38200 MOVE 02,ALF+=11
38300 FADRM 02,BM+2
38400 ; 17500 RJX=RJX+RJ
38500 FADRM 02,ALF+=10
38600 JRST BS930 ;17600 GO TO 930
38700 BS942: SKIPN 14 ;17800 942 IF(J8.NE.0)RETURN
38800 SKIPN .COMM.+=30
38900 JRA 16,(16) ;17900 IF(J9.EQ.0)RETURN
39000 MOVSI 02,205740 ;18000 IF(R10.GE.30)RETURN
39100 SKIPL .COMM.+=28 ;IF(J7.LT.0)RETURN
39200 CAMG 02,.COMM.+=11
39300 JRA 16,(16) ; C FOR NUMBERS OUTSIDE BEAMS
39400 MOVE 02,MIN+1 ;18200 RSTJ2=RMINI
39500 MOVEM 02,STF+=8
39600 MOVN 3,[10.0] ;18300 RD=-10.
39700 MOVSI 02,205500 ;18400 IF(R7.LT.20)RD=8.3
39800 CAMLE 02,.COMM.+=8
39900 MOVE 3,[8.3]
40000 BS943: MOVN 02,ALF+5 ;18500 943 J3=R3Q+(RA-R3Q)/2.
40100 FADR 02,BM
40200 FSC 02,777777
40300 FADR 02,ALF+5
40400 KIFIX 0,2 ;FIX IT
40500 MOVEM 00,.COMM.+=24
40600 ; 18600 R6=1.
40700 MOVSI 02,201400
40800 MOVEM 02,.COMM.+7
40900 ; 18900 R7=1
41000 MOVEM 02,.COMM.+=8 ; C ITALICS
41100 ; 18800 R4=R4+(R5-R4)/2.+RD
41200 MOVE 02,.COMM.+6
41300 FSBR 02,.COMM.+5
41400 FSC 02,777777
41500 FADR 2,3
41600 FADRM 02,.COMM.+5 ↔ SETZM .COMM.+=12 ; R11=0
41700 ; 19100 CALL MAKNUM(R9)
41800 JSA 16,MAKNUM
41900 JUMP .COMM.+=10
42000 JRA 16,(16) ; 19300 END
42100 END